home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / install.tcl < prev    next >
Encoding:
Text File  |  1997-12-20  |  27.2 KB  |  897 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions - an extension package for Alpha
  4.  # 
  5.  #  FILE: "install.tcl"
  6.  #                                    created: 25/7/97 {1:12:02 am} 
  7.  #                                last update: 20/12/97 {6:45:59 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Copyright (c) 1997  Vince Darley
  15.  # 
  16.  #  This file contains a pretty complex package installation
  17.  #  procedure, and some more rudimentary code which queries
  18.  #  an ftp site for a list of packages and checks dates etc
  19.  #  to see if there's something new.  The idea being you can
  20.  #  then just select from a menu to download and subsequently
  21.  #  install.
  22.  #  
  23.  # Package installation:
  24.  # 
  25.  #  There is a new install mode 'Inst' which adds the Install menu.
  26.  #  Install mode is trigerred when a file's name ends in 'Install'
  27.  #  or 'INSTALL', or when the first line of the file contains the
  28.  #  letters 'install', provided in this last case, that the file
  29.  #  is not in Alpha's Tcl hierarchy.  This last case is useful so
  30.  #  that a single .tcl file can be a package and be installed by
  31.  #  Alpha using these nice scripts, without the need for a separate
  32.  #  install-script-file.  However once that .tcl file is installed,
  33.  #  if you open it you certainly wouldn't want it opened in Install mode!
  34.  #  
  35.  # Once you've opened a file in install mode:
  36.  # 
  37.  #  You can select 'install this package' from the menu.  (If the file's
  38.  #  first line contains 'auto-install' the menu item is automatically
  39.  #  selected, provided no modifier key is pressed).  In any case, this 
  40.  #  does the following: if there's an install file in the current directory
  41.  #  it is sourced.  An install file is defined as a file at the same
  42.  #  level as the current file whose name matches "*install*.tcl".
  43.  #  If no install file is found, a default (but still rather
  44.  #  sophisticated) installation takes place, by calling the procedure
  45.  #  'install::packageInstallationDialog'.  Any install script in your
  46.  #  *install*.tcl file may wish to use that procedure anyway.  For
  47.  #  instance, the installer for Vince's Additions uses just the
  48.  #  following lines in its installation file:
  49.  #  
  50.  #     install::packageInstallationDialog "Vince's Additions" "\
  51.  # These additions include a number of different packages, designed to \
  52.  # make using Alpha an even more pleasant experience!  They include a \
  53.  # more sophisticated completion and template mechanism, some bibliography \
  54.  # conversion routines, and a general projects/documents organisation scheme." 
  55.  #     
  56.  # In any case, 'install::packageInstallationDialog' does the following:
  57.  # It scans the current directory for files which may need installing.
  58.  # This includes any .tcl file which is not the *install*.tcl script.
  59.  # It also includes the same in any subdirectories of the current 
  60.  # directory.  Intelligent guesses are made as to whether files are 
  61.  # Modes, Menus, Packages, Completions, Extensions, Help files or
  62.  # UserModifications.
  63.  # 
  64.  # Extensions are *+\d.tcl files, these go in tclExtensionsFolder
  65.  # Modes are *Mode.tcl files, or all files in a subdir *Mode*
  66.  # Menus are *Menu.tcl files, or all files in a subdir *Menu*
  67.  # Completions are all files *Completions.tcl
  68.  # Help files end in 'help' or 'tutorial' (any case)
  69.  # UserModifications are any files in a UserModifications subdir.
  70.  # Packages are anything else.
  71.  # 
  72.  # UserModifications are files which a package installs once, but
  73.  # the user is expected to edit afterwards.  Hence if the package
  74.  # is reinstalled, those files are not overwritten.
  75.  # 
  76.  # Clearly if the original install file was in fact a .tcl file on
  77.  # its own (with 'install' in the first line) then we don't search
  78.  # the directory in which it sits.  This is now implemented.
  79.  # 
  80.  # ----------
  81.  # OK, we've got all the files and worked out where they should go.
  82.  # Now we build an installation dialog, from which the user can
  83.  # select 'Easy Install', or 'Custom Install'.  Easy install does
  84.  # the works, custom allows the user to choose amongst all the 
  85.  # available sub-pieces.  A sub-piece is any single item in the
  86.  # install directory: so you can package up blocks of files as a single
  87.  # package by putting them in a sub-dir.
  88.  # 
  89.  # If you hit 'Ok' installation takes place, with optional backup
  90.  # of removed files.
  91.  # 
  92.  # Currently package indices and tcl indices are then rebuilt.  This
  93.  # last thing needs to be a bit more sophisticated...
  94.  # 
  95.  # ----------
  96.  # Caveats:
  97.  # 
  98.  #     Currently not clever enough to install, say, HTML mode in the
  99.  #     way it currently is: here we wish to install all HTML files in
  100.  #     one sub-dir of the Modes dir, but we wish to allow the user to
  101.  #     pick which sub-sets of files will go in that 'HTML and CSS modes'
  102.  #     directory.  So the user could install just HTML files and ignore
  103.  #     the CSS ones.  The solution I propose is to store such items in
  104.  #     separate subfolder of the base HTML subfolder.  Such items would
  105.  #     then be sub-choices of the base 'install HTML mode' choice, and
  106.  #     when installed, would be installed directly into the HTML mode
  107.  #     dir.
  108.  #     
  109.  # I think I need more feedback before embarking on further 
  110.  # modifications to this code.
  111.  #  
  112.  # ###################################################################
  113.  ##
  114.         
  115. namespace eval install {}
  116. namespace eval file {}
  117.  
  118. proc installMenu {} {}
  119. set installMenu "Install"
  120. set menu::items(Install) [list \
  121.     "installThisPackage" "(-" "rebuildPackageIndices" "rebuildTclIndices"]
  122.  
  123. menu::buildSome Install
  124.  
  125. proc install::rebuildPackageIndices {} { alpha::rebuildPackageIndices }
  126.  
  127. ## 
  128.  # -------------------------------------------------------------------------
  129.  # 
  130.  # "install::installThisPackage" --
  131.  # 
  132.  #  DO NOT CALL THIS PROCEDURE FROM YOUR *install.tcl INSTALLATION SCRIPT
  133.  #  IT WILL CAUSE INFINITE RECURSION AND CRASH ALPHA.  THIS PROCEDURE IS
  134.  #  DESIGNED TO SOURCE YOUR *install.tcl FILE AUTOMATICALLY IF IT EXISTS.
  135.  #  
  136.  #  Instead call install::packageInstallationDialog 
  137.  #  and install::askRebuildQuit
  138.  # -------------------------------------------------------------------------
  139.  ##
  140. proc install::installThisPackage {} {
  141.     # single-file packages by definition don't have an installer.
  142.     if {[file extension [set name [install::name]]] == ".tcl"} {
  143.         install::packageInstallationDialog "Package"
  144.     } else {        
  145.         set currD [file dirname $name]
  146.         if [regexp -nocase {auto-install-script} [getText 0 [nextLineStart 0]]] {
  147.             set installer [list $name]
  148.         } else {
  149.             set installer [glob -nocomplain "$currD:*nstall*.tcl"]
  150.             if {[llength $installer] > 1} {
  151.                 alertnote "This package has two installation files.  This is bad; I'll do a standard installaton."
  152.             }
  153.         }
  154.         
  155.         if {[llength $installer] == 1} {
  156.             global installation_dir
  157.             set installation_dir $currD
  158.             # installer is a one-item list, so no need to wrap it
  159.             uplevel \#0 source $installer
  160.             unset installation_dir
  161.         } else {
  162.             install::packageInstallationDialog "Package"
  163.         }
  164.     }
  165.     global install::forcequit
  166.     install::askRebuildQuit ${install::forcequit}
  167. }
  168.  
  169. proc install::sourceUpdatedSystem {} {
  170.     global HOME install::time
  171.     if ![info exists install::time] { return }
  172.     foreach f [glob -nocomplain ${HOME}:Tcl:SystemCode:*.tcl] {
  173.         if {[file tail $f] == "AlphaBits.tcl" \
  174.           || [file tail $f] == "globals.tcl"} {continue}
  175.         getFileInfo $f info
  176.         if {$info(modified) > ${install::time}} {
  177.             catch [list uplevel \#0 [list source $f]]
  178.         }
  179.     }
  180. }
  181.  
  182. proc install::askRebuildQuit {{force 0}} {
  183.     alertnote "All indices must now be rebuilt for the installation to work."
  184.     if {![key::optionPressed] \
  185.       || [dialog::yesno "Shall I rebuild the indices?"]} {
  186.         install::sourceUpdatedSystem
  187.         set n [alpha::package names]
  188.         alpha::rebuildPackageIndices
  189.         set new [lremove -l [alpha::package names] $n]
  190.         if {![key::optionPressed] \
  191.           || [dialog::yesno "Shall I rebuild the Tcl indices?"]} {
  192.             rebuildTclIndices
  193.         }
  194.         auto_reset
  195.         if [llength $new] {
  196.             if {[dialog::yesno "You just installed the following new packages: $new; do you want to activate them at next startup?"]} {
  197.                 global package::activate modifiedVars
  198.                 eval lappend package::activate $new
  199.                 lappend modifiedVars package::activate
  200.             }
  201.         }
  202.     }
  203.     if {$force || [dialog::yesno "It is recommended that you quit and restart Alpha.  Quit now?"]} {
  204.         if {$force} {alertnote "Alpha must now quit."}
  205.         if {[win::CurrentTail] == "Installation report"} {
  206.             setWinInfo read-only 0
  207.             setWinInfo dirty 1
  208.         }
  209.         quit
  210.     }
  211. }
  212.  
  213. ## 
  214.  # -------------------------------------------------------------------------
  215.  # 
  216.  # "install::openHook" --
  217.  # 
  218.  #  Used when opening an install file to check for an 'auto-install' line.
  219.  # -------------------------------------------------------------------------
  220.  ##
  221. proc install::openHook {name} {
  222.     if {![getModifiers] && [regexp -nocase {auto-install} [getText 0 [nextLineStart 0]]]} {
  223.         moveWin $name 10000 10000
  224.         global install::_name
  225.         set install::_name $name
  226.         catch {install::installThisPackage}
  227.         unset install::_name
  228.         if ![catch {bringToFront $name}] {
  229.             killWindow
  230.         }
  231.     }
  232. }
  233.  
  234. proc install::name {} {
  235.     global install::_name
  236.     if [info exists install::_name] {
  237.         return ${install::_name}
  238.     } else {
  239.         return [win::Current]
  240.     }
  241. }
  242.  
  243. proc install::readAtStartup {w} {
  244.     global alpha::readAtStartup modifiedVars
  245.     lappend alpha::readAtStartup $w
  246.     lappend modifiedVars alpha::readAtStartup
  247. }
  248.  
  249. ## 
  250.  # -------------------------------------------------------------------------
  251.  # 
  252.  # "install::packageInstallationDialog" --
  253.  # 
  254.  #  Optional arguments are as follows:
  255.  #  
  256.  #  -ignore {list of files to ignore}
  257.  #  -remove {list of files to remove from Alpha hierarchy}    
  258.  #  -rebuildquit '0 or 1'  
  259.  #      (prompts the user to rebuild indices and quit; default 1)
  260.  #  -require {Pkg version Pkg version …}
  261.  #      e.g. -require {Alpha 6.52 elecCompletions 7.99}
  262.  #  
  263.  #  and 
  264.  #  
  265.  #  -SystemCode -Modes -Menus
  266.  #  -BugFixes -Completions -Packages
  267.  #  -ExtensionsCode -UserModifications -Tools
  268.  #  
  269.  #  which force the placement of the following list of files.
  270.  # -------------------------------------------------------------------------
  271.  ##
  272. proc install::packageInstallationDialog {{pkgname "Package"} {description ""} args} {
  273.     set win::Current [install::name]
  274.     set currD [file dirname ${win::Current}]
  275.     if {[file extension ${win::Current}] == ".tcl"} {
  276.         # single file to install
  277.         set pkgname [file root [file tail ${win::Current}]]
  278.         set description "I'll install this single-file package, placing\
  279.  it in its correct location in Alpha's code base."
  280.         set rebuild [eval [list install::_packageInstallationDialog $pkgname $description \
  281.             $currD [list [file tail ${win::Current}]]] $args]
  282.     } else {        
  283.         set toplevels [glob -nocomplain "$currD:*.tcl"]
  284.         eval lappend toplevels [glob -nocomplain -t TEXT "$currD:* *"]
  285.         set toplevels [lremove -glob $toplevels *\[Ii\]nstall*]
  286.         set toplevels [lremove -glob $toplevels *INSTALL*]
  287.         set subdirs [glob -nocomplain "$currD:*:"]
  288.         foreach item $toplevels {
  289.             lappend items [file tail $item]
  290.         }
  291.         if [file exists $currD:Changes] {
  292.             lappend items Changes
  293.         }
  294.         foreach dir $subdirs {
  295.             lappend items "[file tail [file dirname $dir]]:"
  296.         }
  297.         set subdirs [lremove -glob $subdirs "*Completions:"]
  298.         set completions [glob -nocomplain "$currD:Completions:"]
  299.         set usermods [glob -nocomplain "$currD:UserModifications:"]
  300.         eval [list install::_packageInstallationDialog $pkgname $description \
  301.             $currD $items] $args
  302.     }
  303. }
  304.  
  305. proc install::_packageInstallationDialog {{pkgname "Package"} {description ""} currD items args} {
  306.     global install::time
  307.     set install::time [now]
  308.     set install_types [list SystemCode CorePackages \
  309.         Modes Menus BugFixes Completions Packages Home \
  310.         ExtensionsCode UserModifications Help QuickStart Tools remove]
  311.     set opts(-ignore) ""
  312.     set opts(-forcequit) 0
  313.     set opts(-require) ""
  314.     foreach type $install_types {
  315.         set opts(-$type) ""
  316.     }
  317.     getOpts [concat provide ignore require rebuildquit forcequit $install_types]
  318.             
  319.     foreach type $install_types {
  320.         if {$opts(-$type) != ""} {
  321.             eval lappend opts(-ignore) $opts(-$type)
  322.             set $type $opts(-$type)
  323.         }
  324.     }
  325.     # check if package requires others:
  326.     array set req $opts(-require)
  327.     foreach pkg [array names req] {
  328.         eval package::reqInstalledVersion [list $pkg] $req($pkg)
  329.     }
  330.     catch {unset req}
  331.     unset opts(-require)
  332.     # check on -provide option
  333.     if [info exists opts(-provide)] {
  334.         array set prov $opts(-provide)
  335.         foreach pkg [array names prov] {
  336.             # check currently installed version isn't newer
  337.             if {![catch {alpha::package versions $pkg} v]} {
  338.                 switch -- [alpha::package vcompare $v $prov($pkg)] {
  339.                     0 {
  340.                         alertnote "Package $pkg version $v is already installed.\
  341.                             You may wish to cancel the installation."
  342.                     }
  343.                     1 {
  344.                         alertnote "This installer is for $pkg version $prov($pkg)\
  345.                           but version $v is already installed. You may wish to\
  346.                           cancel the installation."
  347.                     }
  348.                 }
  349.             }
  350.         }
  351.         catch {unset prov}
  352.         unset opts(-provide)
  353.     }
  354.     # check if package has over-ridden default
  355.     global install::forcequit
  356.     set install::forcequit $opts(-forcequit)
  357.     catch {unset opts(-rebuildquit)}
  358.     unset opts(-forcequit)
  359.     # Now assume packages/modes are sub-dirs, completions are in the
  360.     # Completions dir, and toplevels are obvious from their name.
  361.     # (Mode, Menu, BugFixes or default is in Packages dir)
  362.     
  363.     # Create a dialog:
  364.     if {$description == ""} {
  365.         set description "I'll do a complete installation, placing all modes,\
  366.  menus, completions, help files, tools, extensions and packages in their\
  367.  correct locations.  In\
  368.  addition, any core bug fixes this package contains will be patched into\
  369.  Alpha's core Tcl code."
  370.      }
  371.     set y 80
  372.     set names [list "Easy Install" "Custom Install"]
  373.     lappend dial -n [lindex $names 0]
  374.     eval lappend dial \
  375.         [dialog::text "$description" 15 y 55]
  376.     incr y 10
  377.     eval lappend dial \
  378.         [dialog::checkbox "Backup removed files" 1 20 y]
  379.     eval lappend dial \
  380.       [dialog::checkbox "Show installation log" 1 20 y]
  381.     incr y 22
  382.     eval lappend dial \
  383.       [dialog::text "Click OK to continue with the installation" 15 y]
  384.     if {${install::forcequit}} {
  385.         eval lappend dial \
  386.           [dialog::text "Alpha will quit after this installation." 15 y]
  387.     }  
  388.     set othery [expr $y +10]
  389.     lappend dial -n [lindex $names 1]
  390.     set y 60
  391.     eval lappend dial \
  392.         [dialog::checkbox "Backup removed files" 1 20 y]
  393.     eval lappend dial \
  394.         [dialog::checkbox "Show installation log" 1 20 y]
  395.     incr y 5
  396.     foreach item $items {
  397.         if {[lsearch $opts(-ignore) $item] != -1} {
  398.             continue
  399.         }
  400.         if {[string match *+*.tcl $item]} { 
  401.             lappend ExtensionsCode $item 
  402.         } elseif {[regexp "SystemCode" $item]} { 
  403.             lappend SystemCode $item 
  404.         } elseif {$item == "Changes" || [string match "Writing *" $item]} { 
  405.             lappend Help $item 
  406.         } elseif {[regexp "(H|h)elp:?$" $item]} {
  407.             lappend Help $item 
  408.         } elseif {[regexp -nocase "quick *start$" $item]} {
  409.             lappend QuickStart $item 
  410.         } elseif {[regexp "Modes:?$" $item]} { 
  411.             lappend Modes $item 
  412.         } elseif {[regexp "Menus:?$" $item]} { 
  413.             lappend Menus $item 
  414.         } elseif {[regexp "Docs:" $item]} { 
  415.             lappend Home $item 
  416.         } elseif {[regexp "Tools" $item]} { 
  417.             lappend Tools $item 
  418.         } elseif {[regexp -nocase "mode(:|.tcl)?$" $item]} { 
  419.             lappend Modes $item 
  420.         } elseif {[regexp -nocase "menu(:|.tcl)?$" $item]} { 
  421.             lappend Menus $item 
  422.         } elseif {[regexp -nocase "bugfixes" $item]} {
  423.             lappend BugFixes $item
  424.         } elseif {[regexp "Completions" $item]} {
  425.             lappend Completions $item
  426.         } elseif {[regexp "Tools" $item]} {
  427.             lappend Tools $item
  428.         } elseif {[regexp "UserModifications" $item]} {
  429.             lappend UserModifications $item
  430.         } elseif {[regexp "CorePackages" $item]} {
  431.             lappend CorePackages $item
  432.         } else {
  433.             lappend Packages $item
  434.         }
  435.     }
  436.     set x 20
  437.     set continue 0
  438.     foreach items $install_types {
  439.         if [info exists $items] {
  440.             if {$continue} {
  441.                 set continue 0
  442.                 if {$y + 10 > $othery} { set othery [expr $y +10] }
  443.                 set y 100
  444.                 incr x 190
  445.                 eval lappend dial [dialog::text "continued…" $x y]
  446.             }
  447.             if {$items != "remove"} {
  448.                 set t "Install $items"
  449.             } else {
  450.                 set t "Remove obsolete files"
  451.             }
  452.             eval lappend dial [dialog::text $t $x y]
  453.             foreach item [set $items] {
  454.                 lappend options [list $items $item]
  455.                 regsub ":\$" $item " ƒ" item
  456.                 eval lappend dial [dialog::checkbox $item 1 [expr $x + 20] y]
  457.                 if {$y > 360} {
  458.                     set continue 1
  459.                 }
  460.             }
  461.         }
  462.     }
  463.     incr y 10
  464.     set h [expr $othery > $y ? $othery : $y]
  465.     set yb [expr $h - 70]
  466.     set w [expr 390 + ($x/2)]
  467.     set dials [list dialog -w $w -h $h]
  468.     set y 10
  469.     eval lappend dials [dialog::text "$pkgname installation options" 20 y 35]
  470.     eval lappend dials [dialog::button "OK" [expr $w -80] yb]
  471.     eval lappend dials [dialog::button "Cancel" [expr $w -80] yb]
  472.     set res [eval [concat $dials [list -m [concat [list [lindex $names 0]] $names] 250 10 405 30]  $dial]]
  473.     if [lindex $res 1] { error "Cancel" } 
  474.     # cancel was pressed
  475.     set easy_install [expr 1 - [lsearch $names [lindex $res 2]]]
  476.     if $easy_install {
  477.         set make_backup [lindex $res 3]
  478.         set make_log [lindex $res 4]
  479.     } else {
  480.         set make_backup [lindex $res 5]
  481.         set make_log [lindex $res 6]
  482.     }
  483.     if $make_backup {
  484.         global HOME
  485.         set make_backup "$HOME:InstallationBackup"
  486.     } else {
  487.         set make_backup ""
  488.     }
  489.     set i 6
  490.     global install::_ignore install::log
  491.     set install::_ignore $opts(-ignore)
  492.     set install::log ""
  493.     foreach o $options {
  494.         incr i
  495.         if {!$easy_install && ![lindex $res $i]} { continue }
  496.         set type [lindex $o 0]
  497.         set name [lindex $o 1]
  498.         message "Installing $type '$name'"
  499.         install::files $type $currD $name $make_backup
  500.     }
  501.     unset install::_ignore
  502.     if $make_log {
  503.         install::showLog
  504.     } else {
  505.         unset install::log
  506.     }
  507. }
  508.  
  509. proc install::showLog {{title "Installation report"}} {
  510.     global install::log
  511.     new -g 0 160 640 300 -n $title
  512.     if {${install::log} == ""} {
  513.         insertText "No changes were made.  You must have already installed this package."
  514.     } else {
  515.         insertText ${install::log}
  516.         insertText "End of report."
  517.     }
  518.     goto 0
  519.     winReadOnly
  520.     unset install::log
  521. }
  522.  
  523. proc userMessage {{alerts 1} {message ""}} {
  524.     if $alerts {
  525.         alertnote $message
  526.     } else {
  527.         message $message
  528.     }
  529. }
  530.  
  531. proc file::standardFind {f} {
  532.     global HOME auto_path PREFS tclExtensionsFolder
  533.     set dirs $auto_path
  534.     lappend dirs $HOME:Tcl:Completions $PREFS $HOME:Help $HOME:Tools
  535.     if [info exists tclExtensionsFolder] { lappend dirs $tclExtensionsFolder }
  536.     foreach dir $dirs {
  537.         if [file exists "${dir}:${f}"] {
  538.             return "${dir}:${f}"
  539.         }
  540.     }
  541.     if [regexp : $f] {
  542.         foreach dir $dirs {
  543.             if [file exists "[file dirname ${dir}]:${f}"] {
  544.                 return "[file dirname ${dir}]:${f}"
  545.             }
  546.         }
  547.     }
  548.     error "Not found"    
  549. }
  550.  
  551.  
  552. # Install 'name' from $currD into where it should go    
  553. # If 'name' ends in a colon, it's a directory.  We can just 
  554. # use glob to get a list!
  555. proc install::files {type from name backup} {
  556.     global HOME PREFS tclExtensionsFolder
  557.     set flist [glob -nocomplain $from:$name*]
  558.     switch -- $type {
  559.         Tools {
  560.             set to "${HOME}:Tools"
  561.             foreach f $flist {
  562.                 install::file_to $f $to $backup
  563.             }        
  564.         }        
  565.         remove {
  566.             if ![catch {file::standardFind $name} what] {
  567.                 if {[regexp {:$} $name]} {
  568.                     foreach f [glob -nocomplain ${what}*] {
  569.                         file::removeOne $f $backup
  570.                     }
  571.                     install::log "Removed dir: $name"
  572.                     rmdir $what
  573.                 } else {
  574.                     file::removeOne $what $backup
  575.                 }
  576.             }
  577.         }
  578.         SystemCode -
  579.         Modes -
  580.         Menus - 
  581.         Packages {
  582.             set to "${HOME}:Tcl:${type}"
  583.             if {[regexp {:$} $name] && $name != "${type}:"} {
  584.                 install::file_to $name $to
  585.                 append to ":[file dirname $name]"
  586.             }
  587.             foreach f $flist {
  588.                 install::file_to $f $to $backup
  589.             }        
  590.         }
  591.         CorePackages {
  592.             set to "${HOME}:Tcl:SystemCode:CorePackages"
  593.             if {[regexp {:$} $name] && $name != "${type}:"} {
  594.                 install::file_to $name $to
  595.                 append to ":[file dirname $name]"
  596.             }
  597.             foreach f $flist {
  598.                 install::file_to $f $to $backup
  599.             }        
  600.         }
  601.         QuickStart {
  602.             set to "${HOME}:QuickStart"
  603.             foreach f $flist {
  604.                 install::file_to $f $to $backup
  605.                 install::readAtStartup "${HOME}:QuickStart:[file tail $f]"
  606.             }        
  607.         }
  608.         Home {
  609.             set to "${HOME}"
  610.             if {[regexp {:$} $name] && $name != "${type}:"} {
  611.                 install::file_to $name $to
  612.                 append to ":[file dirname $name]"
  613.             }
  614.             foreach f $flist {
  615.                 install::file_to $f $to $backup
  616.             }        
  617.         }
  618.         Help {
  619.             set to "${HOME}:Help"
  620.             foreach f $flist {
  621.                 install::file_to $f $to $backup
  622.             }        
  623.         }        
  624.         BugFixes {
  625.             foreach f $flist {
  626.                 procs::patchOriginalsFromFile $f 0
  627.                 install::log "Installed patches from $f"
  628.             }
  629.         }
  630.         Completions {
  631.             set to "${HOME}:Tcl:Completions"
  632.             foreach f $flist {
  633.                 install::file_to $f $to $backup
  634.             }        
  635.         }
  636.         UserModifications {
  637.             set to "${HOME}:Tcl:UserModifications"
  638.             global install::noreplace
  639.             set install::noreplace 1
  640.             foreach f $flist {
  641.                 install::file_to $f $to $backup
  642.             }        
  643.             set install::noreplace 0
  644.         }        
  645.         ExtensionsCode {
  646.             if ![info exists tclExtensionsFolder] {
  647.                 set tclExtensionsFolder $PREFS
  648.                 alertnote "This installation contains extension\
  649.                   (+.tcl) files.  These require\
  650.                   the 'Smarter Source' package, which you do not have\
  651.                   installed.  I've put the extension\
  652.                   files in your prefs directory, but they will not operate\
  653.                   without that package."
  654.               }
  655.             set to "$tclExtensionsFolder"
  656.             foreach f $flist {
  657.                 install::file_to $f $to $backup
  658.             }
  659.         }    
  660.     }
  661.     message "File installation complete"
  662. }
  663.  
  664. proc install::log {text} {
  665.     global install::log
  666.     append install::log "${text}\r"
  667. }
  668.  
  669. proc install::file_to {file to {backup ""}} {
  670.     if {[regexp -nocase {(help|tutorial)$} [file tail $file]] \
  671.         || ([file tail $file] == "Changes")} {
  672.         global HOME
  673.         install::_file_to $file "$HOME:Help" $backup
  674.     } elseif [regexp {\+\d*.tcl} [file tail $file]] {
  675.         global tclExtensionsFolder PREFS
  676.         if ![info exists tclExtensionsFolder] { set tclExtensionsFolder $PREFS }
  677.         install::_file_to $file $tclExtensionsFolder $backup
  678.     } else {
  679.         if {[file isdirectory $file]} {
  680.             set to "${to}:[file tail $file]"
  681.             if ![file exists $to] {mkdir $to}
  682.             foreach f [glob "$file:*"] {
  683.                 install::file_to $f $to $backup
  684.             }
  685.         } else {
  686.             install::_file_to $file $to $backup
  687.         }
  688.     }
  689. }
  690.  
  691. proc install::_file_to {file to {backup ""}} {
  692.     global install::_ignore
  693.     foreach suffix ${install::_ignore} {
  694.         if [string match *${suffix} $file] { return }
  695.     }
  696.     message "Installing [file tail $file]"
  697.     if [file::ensureDirExists $to] {
  698.         install::log "Created dir '$to'"
  699.     }
  700.     if [regexp {:$} $file] {
  701.         # Install a directory
  702.         if [file::ensureDirExists "${to}:[file tail [file dirname $file]]"] {
  703.             install::log "Created dir '${to}:[file tail [file dirname $file]]'"
  704.         }
  705.         return
  706.     }
  707.     set files [glob -nocomplain "${file}*"]
  708.     global install::noreplace
  709.     if {[info exists install::noreplace] && ${install::noreplace}} {
  710.         foreach ff $files {
  711.             foreach suffix ${install::_ignore} {
  712.                 if [string match *${suffix} $file] { continue }
  713.             }
  714.             set f [file tail $ff]
  715.             if ![file exists "${to}:$f"] {
  716.                 if [file exists "$ff" ] {
  717.                     cp "$ff" "${to}:$f"
  718.                     install::log "copied '[file tail $ff]' to '${to}:$f'"
  719.                 }
  720.             }
  721.         }
  722.     } else {
  723.         foreach ff $files {
  724.             foreach suffix ${install::_ignore} {
  725.                 if [string match *${suffix} $file] { continue }
  726.             }
  727.             set f [file tail $ff]
  728.             # check if files are actually different before removing
  729.             if [file exists "$ff" ] {
  730.                 if [file exists ${to}:$f] {
  731.                     if {[regexp "tclIndexx?" [file tail $f]] || \
  732.                         [file::sameModifiedDate $ff ${to}:$f]} {
  733.                         continue
  734.                     }
  735.                     file::remove $to [list $f] $backup
  736.                 }
  737.                 cp "$ff" "${to}:$f"
  738.                 install::log "copied '[file tail $ff]' to '${to}:$f'"
  739.             } else {
  740.                 alertnote "Installation file $f does not exist!"
  741.             }
  742.         }
  743.     }
  744. }
  745. ## 
  746.  # -------------------------------------------------------------------------
  747.  # 
  748.  # "file::hyperOpen" --
  749.  # 
  750.  #  Called by embedded hyperlinks; we look through an installation
  751.  #  directory (and subdirs) if it is known, then the prefs directory, 
  752.  #  then all of the auto_path.  If the file is of type TEXT, we open
  753.  #  it, else we ask the finder to open it.
  754.  # -------------------------------------------------------------------------
  755.  ##
  756. proc file::hyperOpen { name } {
  757.     global PREFS tclExtensionsFolder auto_path
  758.     set currD [list [file dirname [win::Current]]]
  759.     set dirs [glob -nocomplain "$currD:*:"]
  760.     foreach d $dirs {
  761.         lappend currD [string trimright $d :]
  762.     }
  763.     lappend currD $PREFS 
  764.     if [info exists tclExtensionsFolder] { lappend currD $tclExtensionsFolder }
  765.     foreach d [concat $currD $auto_path] {
  766.         if [file exists "$d:$name" ] {
  767.             file::openAny "$d:$name"
  768.             return
  769.         }
  770.     }
  771.     beep
  772.     message "Sorry, couldn't find $name"
  773. }
  774. ## 
  775.  # -------------------------------------------------------------------------
  776.  # 
  777.  # "file::hyperHelpOpen" --
  778.  # 
  779.  #  Called by embedded hyperlinks; we look through an installation
  780.  #  directory (and subdirs) if it is known, then the prefs directory, 
  781.  #  then all of the auto_path.
  782.  # -------------------------------------------------------------------------
  783.  ##
  784. proc file::hyperHelpOpen { name } {
  785.     global HOME auto_path 
  786.     set currD [list [file dirname [win::Current]]]
  787.     set dirs [glob -nocomplain "$currD:*:"]
  788.     foreach d $dirs {
  789.         lappend currD [string trimright $d :]
  790.     }
  791.     lappend currD $HOME:Help
  792.     foreach d [concat $currD $auto_path] {
  793.         set ns [glob -nocomplain "$d:${name}*"]
  794.         foreach n $ns {
  795.             if [regexp -nocase "help" [file tail $n]] {
  796.                 edit $n
  797.                 return
  798.             }
  799.         }
  800.     }
  801.     beep
  802.     message "Sorry, couldn't find a help file for $name"
  803. }
  804.  
  805. ## 
  806.  # -------------------------------------------------------------------------
  807.  # 
  808.  # "file::jumpToCode" --
  809.  # 
  810.  #  It creates a hyperlink to a specific string in a code file, without
  811.  #  requiring a mark to be defined there. It was handy for identifying places 
  812.  #  in other packages that potentially collide with my key-bindings.
  813.  #  
  814.  #  Author: Jon Guyer.
  815.  # -------------------------------------------------------------------------
  816.  ##
  817. proc file::jumpToCode {text file code} {
  818.     set hyper {edit -c }
  819.     append hyper $file
  820.     append hyper { ; set pos [search -f 1 -r 1 "}
  821.     append hyper $code
  822.     append hyper {"] ; select [lindex $pos 0] [lindex $pos 1]}
  823.     file::searchAndHyperise $text $hyper 0 3
  824. }
  825.  
  826.  
  827. proc file::sameModifiedDate {a b} {
  828.     getFileInfo $a infoa
  829.     getFileInfo $b infob
  830.     # bigger = newer
  831.     set ma $infoa(modified)
  832.     set mb $infob(modified)
  833.     return [expr $ma == $mb ? 1 : 0]
  834. }
  835.  
  836. proc file::secondIsOlder {a b} {
  837.     getFileInfo [stripNameCount $a] infoa
  838.     getFileInfo [stripNameCount $b] infob
  839.     # bigger = newer
  840.     set ma $infoa(modified)
  841.     set mb $infob(modified)
  842.     return [expr $ma > $mb ? 1 : 0]
  843. }
  844.  
  845. proc file::replaceSecondIfOlder {a b} {
  846.     if ![file exists $a] { error "First does not exist!" }
  847.     if ![file exists $b] { error "Second does not exist!" }
  848.     if [file::secondIsOlder $a $b] {
  849.         set open [file::removeCheckingWins $b]
  850.         cp $a $b
  851.         install::log "Copied [file tail $a] to $b"
  852.         if $open {
  853.             openFileQuietly $b
  854.         }
  855.         return 1
  856.     } elseif [file::secondIsOlder $b $a] {
  857.         install::log "The pre-existing [file tail $a] is newer than the one which was to be installed."
  858.     }
  859.     return 0
  860. }
  861.  
  862. proc file::removeCheckingWins {f} {
  863.     install::log "Removed $f"
  864.     if {[set i [lsearch -regexp [winNames -f] "^[quote::Regfind $f]( <\d+>)?$"]] != -1} {
  865.         bringToFront [lindex [winNames -f] $i]
  866.         killWindow
  867.         removeFile $f
  868.         return 1
  869.     }
  870.     removeFile $f
  871.     return 0
  872. }
  873.  
  874. proc file::remove {to files {backup ""}} {
  875.     foreach f $files {
  876.         if [file exists "${to}:$f" ] {
  877.             file::removeOne "${to}:$f" $backup
  878.         }
  879.     }
  880. }
  881.  
  882. proc file::removeOne {f {backup ""}} {
  883.     set ff [file tail $f]
  884.     message "Removing old '$ff'"
  885.     if {${backup} != ""} {
  886.         if ![file exists $backup] { mkdir $backup }
  887.         set i ""
  888.         while {[file exists ${backup}:$ff$i]} {
  889.             if {$i == ""} { set i 0}
  890.             incr i
  891.         }
  892.         cp $f ${backup}:$ff$i
  893.     }
  894.     file::removeCheckingWins $f
  895. }
  896.  
  897.